home *** CD-ROM | disk | FTP | other *** search
/ Collection of Tools & Utilities / Collection of Tools and Utilities.iso / ada / gwuada_9.zip / EVAL.C < prev    next >
C/C++ Source or Header  |  1993-07-27  |  48KB  |  1,740 lines
  1. /*
  2.  * Copyright (C) 1985-1992  New York University
  3.  * 
  4.  * This file is part of the Ada/Ed-C system.  See the Ada/Ed README file for
  5.  * warranty (none) and distribution info and also the GNU General Public
  6.  * License for more details.
  7.  
  8.  */
  9.  
  10. #include "hdr.h"
  11. #include "vars.h"
  12. #include "attr.h"
  13. #include "arithp.h"
  14. #include "setp.h"
  15. #include "errmsgp.h"
  16. #include "nodesp.h"
  17. #include "machinep.h"
  18. #include "sspansp.h"
  19. #include "chapp.h"
  20. #include "miscp.h"
  21. #include "smiscp.h"
  22. #include "evalp.h"
  23.  
  24. /* Define DETAIL to break up some complicated expresssions into
  25.  * several statements to assist debugging using interactive debugger
  26.  */
  27. #define DETAIL
  28.  
  29. static Const const_val(Symbol);
  30. static Const eval_lit_map(Symbol);
  31. static Const const_fold(Node);
  32. static Const fold_unop(Node);
  33. static Const fold_op(Node);
  34. static Const fold_attr(Node);
  35. static Const fold_convert(Node);
  36. static Const eval_qual_range(Node, Symbol);
  37. static Const eval_real_type_attribute(Node);
  38. static Const check_overflow(Node, Const);
  39. static int  *fl_mantissa(int);
  40. static int *fl_emax(int);
  41. static void insert_and_prune(Node, Const);
  42. static Rational fx_max (Rational, Rational);
  43. static Const test_expr(int);
  44.  
  45. extern Const int_const(), real_const(), rat_const();
  46. extern ADA_MIN_INTEGER;
  47.  
  48. /* TBSL:provide proper link to ADA_SMALL_REAL*/
  49. #define ADA_SMALL_REAL 0.1
  50.  
  51. static Const const_val(Symbol obj)                                /*;const_val*/
  52. {
  53.     /* Return the constant value of the object if it has one;
  54.      * else return om.
  55.      * The constant value of a user-defined constant is derived from
  56.      * its SIGNATURE, when this is a constant value.
  57.      * The constant value of a literal is obtained from the literal map
  58.      * of its type.
  59.      */
  60.  
  61.     Tuple    sig;
  62.  
  63.     if (cdebug2 > 3) TO_ERRFILE("const_val");
  64.  
  65.     if (is_literal(obj)) return eval_lit_map(obj);
  66.  
  67.     sig = SIGNATURE(obj);
  68.     if( is_constant(obj) && is_scalar_type(TYPE_OF(obj))
  69.       && N_KIND((Node)sig) == as_ivalue) {
  70.         return (Const) N_VAL((Node)sig);
  71.         /* TBSL: could be static but not constant folded yet. */
  72.     }
  73.     else return const_new(CONST_OM);
  74. }
  75.  
  76. static Const eval_lit_map(Symbol obj)                    /*;eval_lit_map*/
  77. {
  78.     Symbol    typ;
  79.     Tuple    tup;
  80.     int    i;
  81.  
  82.     typ = TYPE_OF(obj);
  83.     tup = (Tuple) literal_map(typ);
  84.     for (i = 1; i <= tup_size(tup); i += 2) {
  85.         if (ORIG_NAME(obj) == (char *)0) continue;
  86.         if (streq(tup[i], ORIG_NAME(obj)))
  87.             return int_const((int)tup[i+1]);
  88.     }
  89.     return const_new(CONST_OM);
  90.     /*(return literal_map(TYPE_OF(obj))(original_name(obj));*/
  91. }
  92.  
  93. void eval_static(Node node)                                /*;eval_static*/
  94. {
  95.     /* Top level evaluation of static expressions and constant folding. The
  96.      * recursive procedure const_fold is invoked, and a top-level range 
  97.      * check on numeric results is performed.
  98.      */
  99.     /* If the node type is set to as_ivalue, the the N_VAL field will
  100.      * be a Const.
  101.      */
  102.     Const    result;
  103.  
  104.     result = const_fold(node);
  105.     if (result->const_kind != CONST_OM)
  106.         check_overflow(node, result);
  107. }
  108.  
  109. static Const const_fold(Node node)                            /*;const_fold*/
  110. {
  111.     /* This recursive procedure evaluates expressions, when static.
  112.      * If node is static, its actual value     is returned,  and the    node is
  113.      * modified to be an ivalue. Otherwise const_fold returns om, and node
  114.      * is    untouched. If the static  evaluation shows that the  expression
  115.      * would  raise an exception, a ['raise' exception] value  is produced
  116.      * and placed on the tree.
  117.      */
  118.  
  119.     Fortup ft1;
  120.     Node expn, index_list, index, discr_range;
  121.     Const    result;
  122.     Node    opn;
  123.     Node    n2, op_range;
  124.     Symbol    sym, op_type;
  125.  
  126.     /* */
  127. #define is_simple_value(t) ((t)->const_kind == CONST_INT \
  128.     || (t)->const_kind == CONST_UINT || (t)->const_kind == CONST_REAL)
  129.  
  130.     if (cdebug2 > 3) { }
  131.  
  132.     switch (N_KIND(node)) {
  133.     case(as_simple_name):
  134.         result = const_val(N_UNQ(node));
  135.         break;
  136.     case(as_ivalue):
  137.         result = (Const) N_VAL(node);
  138.         break;
  139.     case(as_int_literal):
  140.         /* TBSL: assuming int literal already converted check this Const*/
  141.         result = (Const) N_VAL(node);
  142.         break;
  143.     case(as_real_literal):
  144.         /*TBSL: assuming real literal already converted */
  145.         result = (Const) N_VAL(node);
  146.         break;
  147.     case(as_string_ivalue):
  148.         /* Will be static if required type has static low bound.*/
  149.         /*        indx := index_type(N_TYPE(node));
  150.          *        [-, lo_exp, -] := signature(indx);
  151.          * * Move this test to the expander, once format of aggregates is known.
  152.          *        if is_static_expr(lo_exp) then
  153.          *           lob := N_VAL(lo_exp);
  154.          *           av  := [v : [-, v] in comp_list];
  155.          *           result := check_null_aggregate(av, lob, indices, node);
  156.          *           result := ['array_ivalue', [v: [-, v] in comp_list], 
  157.          *                       lob, lob + #comp_list - 1];
  158.          *        else
  159.          */
  160.         result = const_new(CONST_OM);
  161.         /*        end if;    */
  162.         break;
  163.     case(as_character_literal):
  164.         result = const_new(CONST_STR);
  165.         break;
  166.     case(as_un_op):
  167.         result = fold_unop(node);
  168.         break;
  169.     case(as_in):
  170.         opn = N_AST1(node);
  171.         op_range = N_AST2(node);
  172.         result = eval_qual_range(opn, N_TYPE(op_range));
  173.         if (is_const_constraint_error(result))
  174.             result = test_expr(FALSE);
  175.         else if (!is_const_om(result))
  176.             result = test_expr(TRUE);
  177.         break;
  178.     case(as_notin):
  179.         opn = N_AST1(node);
  180.         n2 = N_AST2(node);
  181.         result = eval_qual_range(opn, N_TYPE(n2));
  182.         if (is_const_constraint_error(result))
  183.             result = test_expr(TRUE);
  184.         else if (!is_const_constraint_error(result))
  185.             result = test_expr(FALSE);
  186.         break;
  187.     case(as_op):
  188.         result = fold_op(node);
  189.         break;
  190.     case(as_call):
  191.         {
  192.             int i;
  193.             Tuple arg_list;
  194.             Const arg;
  195.  
  196.             opn = N_AST1(node);
  197.             result = const_new(CONST_OM);       /* in general not static */
  198.             arg_list = N_LIST(N_AST2(node));    /* but can fold actuals. */
  199.             for (i = 1; i <= tup_size(arg_list); i++)
  200.                 arg = const_fold((Node)arg_list[i]);
  201.             if (N_KIND(opn) == as_simple_name) {
  202.                 sym = ALIAS(N_UNQ(opn));
  203.                 if (sym != (Symbol)0 && is_literal(sym))
  204.                     /* replace call by actual value of literal */
  205.                     result = eval_lit_map(sym);
  206.             }
  207.         }
  208.         break;
  209.     case(as_parenthesis):
  210.         /* If the parenthesised expression is evaluable, return
  211.          * its value. Otherwise leave it parenthesised.
  212.          */
  213.         opn = N_AST1(node);
  214.         result = const_fold(opn);
  215.         break;
  216.     case(as_qual_range):
  217.         opn = N_AST1(node);
  218.         op_type = N_TYPE(node);
  219.         result = eval_qual_range(opn, op_type);
  220.         if (is_const_constraint_error(result)) {
  221.             create_raise(node, symbol_constraint_error);
  222.             result = const_new(CONST_OM);
  223.         }
  224.         break;
  225.     case(as_qual_index):
  226.         eval_static(N_AST1(node));
  227.         result = const_new(CONST_OM);
  228.         break;
  229.     case(as_attribute):
  230.     case(as_range_attribute):
  231.         /* use separate procedure for C */
  232.         result = fold_attr(node);
  233.         break;
  234.     case(as_qualify):
  235.         if (fold_context)
  236.             result = const_fold(N_AST2(node));
  237.         else
  238.             /* in the context of a conformance check, keep qualification.*/
  239.             result = const_new(CONST_OM);
  240.         break;
  241.         /* Type conversion:
  242.          * /TBSL/ These conversions are not properly checked!
  243.          */
  244.     case(as_convert):
  245.         /* use separate procedure for C */
  246.         result = fold_convert(node);
  247.         break;
  248.     case(as_array_aggregate):
  249.         /* This is treated in the expander.*/
  250.         result = const_new(CONST_OM);
  251.         break;
  252.     case(as_record_aggregate):
  253.         result = const_new(CONST_OM);
  254.         break;
  255.     case(as_selector): /*TBSL Case for discriminants needed */
  256.         expn = N_AST1(node);
  257.         eval_static(expn);
  258.         return const_new(CONST_OM);
  259.     case(as_slice):
  260.         expn = N_AST1(node);
  261.         discr_range = N_AST2(node);
  262.         eval_static(expn);
  263.         eval_static(discr_range);
  264.         return const_new(CONST_OM);
  265.     case(as_row):    /* Not folded for now.*/
  266.         /* p1 := check_const_val(op1);
  267.          * if is_value(op1) then
  268.          *    result := ['array_ivalue', [op1(2)], 1, 1];
  269.          * else
  270.          */
  271.         return const_new(CONST_OM);
  272.     case(as_index):
  273.         expn = N_AST1(node);
  274.         index_list = N_AST2(node);
  275.         eval_static(expn);
  276.  
  277.         FORTUP(index = (Node), N_LIST(index_list), ft1)
  278.             eval_static(index);
  279.         ENDFORTUP(ft1);
  280.         return const_new(CONST_OM);
  281.     default:
  282.         result = const_new(CONST_OM);
  283.     }
  284.     if (result->const_kind != CONST_OM)
  285.         insert_and_prune(node, result);
  286.  
  287.     return result;
  288. }
  289.  
  290. static Const fold_unop(Node node)                                /*;fold_unop*/
  291. {
  292.     Node    opn, oplist;
  293.     Const    result, op1;
  294.     int    op1_kind;
  295.     Symbol    sym;
  296.  
  297.     opn = N_AST1(node);
  298.     oplist = N_AST2(node);
  299.     op1 = const_fold((Node) (N_LIST(oplist))[1]);
  300.  
  301.     if (is_const_om(op1)) return op1;
  302.  
  303.     op1_kind = op1->const_kind;
  304.  
  305.     sym = N_UNQ(opn);
  306.     if (sym == symbol_addui